home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / C and C++ / Entertainment / MacMud / Mud 4.0 / postlang.y < prev    next >
Encoding:
Text File  |  1993-03-16  |  52.3 KB  |  1,844 lines  |  [TEXT/tefi]
  1. /*
  2.  * These are token values that needn't have an associated code for the
  3.  * compiled file
  4.  */
  5.  
  6. %token F_CASE F_DEFAULT F_RANGE
  7.  
  8. %union
  9. {
  10.     int number;
  11.     unsigned int address;    /* Address of an instruction */
  12.     char *string;
  13.     short type;
  14.     struct { int key; char block; } case_label;
  15.     struct function *funp;
  16. }
  17.  
  18. %type <number> assign F_NUMBER constant F_LOCAL_NAME expr_list
  19. %type <number> const1 const2 const3 const4 const5 const6 const7 const8 const9
  20. %type <number> lvalue_list argument type basic_type optional_star expr_list2
  21. %type <number> type_modifier type_modifier_list opt_basic_type block_or_semi
  22. %type <number> argument_list m_expr_list m_expr_list2
  23. %type <string> F_IDENTIFIER F_STRING string_con1 string_constant function_name any_ident
  24.  
  25. %type <case_label> case_label
  26.  
  27. /* The following symbos return type information */
  28.  
  29. %type <type> function_call lvalue string cast expr28 expr01 comma_expr
  30. %type <type> expr2 expr211 expr1 expr212 expr213 expr24 expr22 expr23 expr25
  31. %type <type> expr27 expr28 expr24 expr3 expr31 expr4 number expr0
  32. %%
  33.  
  34. all: program;
  35.  
  36. program: program def possible_semi_colon
  37.        |     /* empty */ ;
  38.  
  39. possible_semi_colon: /* empty */
  40.                    | ';' { yyerror("Extra ';'. Ignored."); };
  41.  
  42. inheritance: type_modifier_list F_INHERIT F_STRING ';'
  43.         {
  44.             struct object *ob;
  45.             struct inherit inherit;
  46.             int initializer;
  47.  
  48.             ob = find_object2($3);
  49.             if (ob == 0) {
  50.             inherit_file = $3;
  51.             /* Return back to load_object() */
  52.             YYACCEPT;
  53.             }
  54.             xfree($3);
  55.             if (ob->flags & O_APPROVED)
  56.             approved_object = 1;
  57.             inherit.prog = ob->prog;
  58.             inherit.function_index_offset =
  59.             mem_block[A_FUNCTIONS].current_size /
  60.                 sizeof (struct function);
  61.             inherit.variable_index_offset =
  62.             mem_block[A_VARIABLES].current_size /
  63.                 sizeof (struct variable);
  64.             inherit.type = $1;
  65.             add_to_mem_block(A_INHERITS, &inherit, sizeof inherit);
  66.             copy_variables(ob->prog, $1);
  67.             initializer = copy_functions(ob->prog, $1);
  68.             if (initializer > 0) {
  69.             struct function *funp;
  70.             int f;
  71.             f = define_new_function("::__INIT", 0, 0, 0, 0, 0);
  72.             funp = FUNCTION(f);
  73.             funp->offset = mem_block[A_INHERITS].current_size /
  74.                 sizeof (struct inherit) - 1;
  75.             funp->flags = NAME_STRICT_TYPES |
  76.                 NAME_INHERITED | NAME_HIDDEN;
  77.             funp->type = TYPE_VOID;
  78.             funp->function_index_offset = initializer;
  79.             transfer_init_control();
  80.             ins_f_byte(F_CALL_FUNCTION_BY_ADDRESS);
  81.             ins_short(f);
  82.             ins_byte(0);    /* Actual number of arguments */
  83.             ins_f_byte(F_POP_VALUE);
  84.             add_new_init_jump();
  85.             }
  86.         }
  87.  
  88. number: F_NUMBER
  89.     {
  90.         if ( $1 == 0 ) {
  91.         ins_f_byte(F_CONST0); $$ = TYPE_ANY;
  92.         } else if ( $1 == 1 ) {
  93.         ins_f_byte(F_CONST1); $$ = TYPE_NUMBER;
  94.         } else {
  95.         ins_f_byte(F_NUMBER); ins_long($1); $$ = TYPE_NUMBER;
  96.         }
  97.     } ;
  98.  
  99. optional_star: /* empty */ { $$ = 0; } | '*' { $$ = TYPE_MOD_POINTER; } ;
  100.  
  101. block_or_semi: block { $$ = 0; } | ';' { $$ = ';'; } ;
  102.  
  103. def: type optional_star F_IDENTIFIER
  104.     {
  105.         /* Save start of function. */
  106.         push_explicit(mem_block[A_PROGRAM].current_size);
  107.  
  108.         if ($1 & TYPE_MOD_MASK) {
  109.         exact_types = $1 | $2;
  110.         } else {
  111.         if (pragma_strict_types)
  112.             yyerror("\"#pragma strict_types\" requires type of function");
  113.         exact_types = 0;
  114.         }
  115.     }
  116.     '(' argument ')'
  117.     {
  118.         /*
  119.          * Define a prototype. If it is a real function, then the
  120.          * prototype will be replaced below.
  121.          */
  122.         define_new_function($3, $6, 0, 0,
  123.                 NAME_UNDEFINED|NAME_PROTOTYPE, $1 | $2);
  124.     }
  125.         block_or_semi
  126.     {
  127.         /* Either a prototype or a block */
  128.         if ($9 == ';') {
  129.         (void)pop_address(); /* Not used here */
  130.         } else {
  131.         define_new_function($3, $6, current_number_of_locals - $6+
  132.             ( max_break_stack_need -1 ) / sizeof(struct svalue) +1,
  133.             pop_address(), 0, $1 | $2);
  134.         ins_f_byte(F_CONST0); ins_f_byte(F_RETURN);
  135.         }
  136.         free_all_local_names();
  137.         xfree($3);        /* Value was copied above */
  138.     }
  139.    | type name_list ';' { if ($1 == 0) yyerror("Missing type"); }
  140.    | inheritance ;
  141.  
  142. new_arg_name: type optional_star F_IDENTIFIER
  143.     {
  144.         if (exact_types && $1 == 0) {
  145.         yyerror("Missing type for argument");
  146.         add_local_name($3, TYPE_ANY);    /* Supress more errors */
  147.         } else {
  148.         add_local_name($3, $1 | $2);
  149.         }
  150.     }
  151.       | type F_LOCAL_NAME
  152.         {yyerror("Illegal to redeclare local name"); } ;
  153.  
  154. argument: /* empty */ { $$ = 0; }
  155.       | argument_list ;
  156.  
  157. argument_list: new_arg_name { $$ = 1; }
  158.          | argument_list ',' new_arg_name { $$ = $1 + 1; } ;
  159.  
  160. type_modifier: F_NO_MASK { $$ = TYPE_MOD_NO_MASK; }
  161.          | F_STATIC { $$ = TYPE_MOD_STATIC; }
  162.          | F_PRIVATE { $$ = TYPE_MOD_PRIVATE; }
  163.          | F_PUBLIC { $$ = TYPE_MOD_PUBLIC; }
  164.          | F_VARARGS { $$ = TYPE_MOD_VARARGS; }
  165.          | F_PROTECTED { $$ = TYPE_MOD_PROTECTED; } ;
  166.  
  167. type_modifier_list: /* empty */ { $$ = 0; }
  168.           | type_modifier type_modifier_list { $$ = $1 | $2; } ;
  169.  
  170. type: type_modifier_list opt_basic_type { $$ = $1 | $2; current_type = $$; } ;
  171.  
  172. cast: '(' basic_type optional_star ')'
  173.     {
  174.         $$ = $2 | $3;
  175.     } ;
  176.  
  177. opt_basic_type: basic_type | /* empty */ { $$ = TYPE_UNKNOWN; } ;
  178.  
  179. basic_type: F_STATUS { $$ = TYPE_NUMBER; current_type = $$; }
  180.     | F_INT { $$ = TYPE_NUMBER; current_type = $$; }
  181.     | F_STRING_DECL { $$ = TYPE_STRING; current_type = $$; }
  182.     | F_OBJECT { $$ = TYPE_OBJECT; current_type = $$; }
  183.     | F_VOID {$$ = TYPE_VOID; current_type = $$; }
  184.     | F_MIXED { $$ = TYPE_ANY; current_type = $$; } 
  185.     | F_MAPPING { $$ = TYPE_MAPPING; current_type = $$; };
  186.  
  187. name_list: new_name
  188.      | new_name ',' name_list;
  189.  
  190. new_name: optional_star F_IDENTIFIER
  191.     {
  192.         define_variable($2, current_type | $1, 0);
  193.         xfree($2);
  194.     }
  195. | optional_star F_IDENTIFIER
  196.     {
  197.         int var_num;
  198.         define_variable($2, current_type | $1, 0);
  199.         var_num = verify_declared($2);
  200.         transfer_init_control();
  201.         ins_f_byte(F_PUSH_IDENTIFIER_LVALUE);
  202.         ins_byte(var_num);
  203.     }
  204.     '=' expr0
  205.     {
  206.         if (!compatible_types((current_type | $1) & TYPE_MOD_MASK, $5)){
  207.         char buff[100];
  208.         sprintf(buff, "Type mismatch %s when initializing %s",
  209.             get_two_types(current_type | $1, $5), $2);
  210.         yyerror(buff);
  211.         }
  212.         ins_f_byte(F_ASSIGN);
  213.         ins_f_byte(F_POP_VALUE);
  214.         add_new_init_jump();
  215.         xfree($2);
  216.     } ;
  217. block: '{' local_declarations statements '}'
  218.     { ; };
  219.  
  220. local_declarations: /* empty */
  221.           | local_declarations basic_type local_name_list ';' ;
  222.  
  223. new_local_name: optional_star F_IDENTIFIER
  224.     {
  225.         add_local_name($2, current_type | $1);
  226.     } ;
  227.  
  228. local_name_list: new_local_name
  229.     | new_local_name ',' local_name_list ;
  230.  
  231. statements: /* empty */
  232.       | statement statements
  233.       | error ';' ;
  234.  
  235. statement: comma_expr ';'
  236.     {
  237.         ins_f_byte(F_POP_VALUE);
  238.         if (d_flag)
  239.         ins_f_byte(F_BREAK_POINT);
  240.         /* if (exact_types && !TYPE($1,TYPE_VOID))
  241.         yyerror("Value thrown away"); */
  242.     }
  243.      | cond | while | do | for | switch | case | default | return ';'
  244.      | block
  245.        | /* empty */ ';'
  246.      | F_BREAK ';'    /* This code is a jump to a jump */
  247.         {
  248.             if (current_break_address == 0)
  249.             yyerror("break statement outside loop");
  250.             if (current_break_address & BREAK_ON_STACK) {
  251.             ins_f_byte(F_BREAK);
  252.             } else {
  253.                 ins_f_byte(F_JUMP); ins_short(current_break_address);
  254.             }
  255.         }
  256.      | F_CONTINUE ';'    /* This code is a jump to a jump */
  257.         {
  258.             if (current_continue_address == 0)
  259.             yyerror("continue statement outside loop");
  260.             ins_f_byte(F_JUMP); ins_short(current_continue_address);
  261.         }
  262.          ;
  263.  
  264. while:  {   push_explicit(current_continue_address);
  265.         push_explicit(current_break_address);
  266.         current_continue_address = mem_block[A_PROGRAM].current_size;
  267.     } F_WHILE '(' comma_expr ')'
  268.     {
  269.         ins_f_byte(F_JUMP_WHEN_NON_ZERO); ins_short(0);    /* to block */
  270.         current_break_address = mem_block[A_PROGRAM].current_size;
  271.         ins_f_byte(F_JUMP); ins_short(0);    /* Exit loop */
  272.         upd_short(current_break_address-2,
  273.               mem_block[A_PROGRAM].current_size);
  274.     }
  275.        statement
  276.     {
  277.       ins_f_byte(F_JUMP); ins_short(current_continue_address);
  278.       upd_short(current_break_address+1,
  279.             mem_block[A_PROGRAM].current_size);
  280.       current_break_address = pop_address();
  281.       current_continue_address = pop_address();
  282.         }
  283.  
  284. do: {
  285.         int tmp_save;
  286.         push_explicit(current_continue_address);
  287.     push_explicit(current_break_address);
  288.     /* Jump to start of loop. */
  289.     ins_f_byte(F_JUMP); tmp_save = mem_block[A_PROGRAM].current_size;
  290.     ins_short(0);
  291.     current_break_address = mem_block[A_PROGRAM].current_size;
  292.     /* Jump to end of loop. All breaks go through this one. */
  293.     ins_f_byte(F_JUMP); push_address(); ins_short(0);
  294.     current_continue_address = mem_block[A_PROGRAM].current_size;
  295.     upd_short(tmp_save, current_continue_address);
  296.         push_address();
  297.     
  298.     } F_DO statement F_WHILE '(' comma_expr ')' ';'
  299.     {
  300.     ins_f_byte(F_JUMP_WHEN_NON_ZERO); ins_short(pop_address());
  301.     /* Fill in the break jump address in the beginning of the loop. */
  302.     upd_short(pop_address(), mem_block[A_PROGRAM].current_size);
  303.     current_break_address = pop_address();
  304.     current_continue_address = pop_address();
  305.     }
  306.  
  307. for: F_FOR '('      { push_explicit(current_continue_address);
  308.             push_explicit(current_break_address); }
  309.      for_expr ';' {   ins_f_byte(F_POP_VALUE);
  310.               push_address();
  311.           }
  312.      for_expr ';' {
  313.             ins_f_byte(F_JUMP_WHEN_NON_ZERO);
  314.             ins_short(0);    /* Jump to block of block */
  315.             current_break_address = mem_block[A_PROGRAM].current_size;
  316.             ins_f_byte(F_JUMP); ins_short(0);    /* Out of loop */
  317.              current_continue_address =
  318.             mem_block[A_PROGRAM].current_size;
  319.           }
  320.      for_expr ')' {
  321.              ins_f_byte(F_POP_VALUE);
  322.             ins_f_byte(F_JUMP); ins_short(pop_address());
  323.             /* Here starts the block. */
  324.             upd_short(current_break_address-2,
  325.                   mem_block[A_PROGRAM].current_size);
  326.           }
  327.      statement
  328.    {
  329.        ins_f_byte(F_JUMP); ins_short(current_continue_address);
  330.        /* Now, the address of the end of the block is known. */
  331.        upd_short(current_break_address+1, mem_block[A_PROGRAM].current_size);
  332.        current_break_address = pop_address();
  333.        current_continue_address = pop_address();
  334.    }
  335.  
  336. for_expr: /* EMPTY */ { ins_f_byte(F_CONST1); }
  337.         | comma_expr;
  338.  
  339. switch: F_SWITCH '(' comma_expr ')'
  340.     {
  341.         current_break_stack_need += sizeof(short);
  342.         if ( current_break_stack_need > max_break_stack_need )
  343.             max_break_stack_need = current_break_stack_need;
  344.     push_explicit(current_case_number_heap);
  345.     push_explicit(current_case_string_heap);
  346.     push_explicit(zero_case_label);
  347.     push_explicit(current_break_address);
  348.     ins_f_byte(F_SWITCH);
  349.     ins_byte(0xff); /* kind of table */
  350.     current_case_number_heap = mem_block[A_CASE_NUMBERS].current_size;
  351.     current_case_string_heap = mem_block[A_CASE_STRINGS].current_size;
  352.     zero_case_label = NO_STRING_CASE_LABELS;
  353.     ins_short(0); /* address of table */
  354.     current_break_address = mem_block[A_PROGRAM].current_size |
  355.                 BREAK_ON_STACK | BREAK_FROM_CASE ;
  356.     ins_short(0); /* break address to push, table is entered before */
  357.     ins_short(0); /* default address */
  358.     }
  359.       statement
  360.     {
  361.     char *heap_start;
  362.     int heap_end_offs;
  363.     int i,o;
  364.     int current_key,last_key;
  365.     /* int size_without_table; */
  366.     int block_index;
  367.     int current_case_heap;
  368.     int lookup_start;
  369.     int lookup_start_key;
  370.  
  371.     current_break_address &= ~(BREAK_ON_STACK|BREAK_FROM_CASE);
  372.  
  373.     if ( !read_short(current_break_address+2 ) )
  374.         upd_short(current_break_address+2,     /* no default given ->  */
  375.           mem_block[A_PROGRAM].current_size);  /* create one           */
  376.  
  377.     /* it isn't unusual that the last case/default has no break */
  378.     ins_f_byte(F_BREAK);
  379.     if(zero_case_label & (NO_STRING_CASE_LABELS|SOME_NUMERIC_CASE_LABELS)){
  380.         block_index = A_CASE_NUMBERS;
  381.         current_case_heap = current_case_number_heap;
  382.     } else {
  383.         block_index = A_CASE_STRINGS;
  384.         current_case_heap = current_case_string_heap;
  385.         if (zero_case_label&0xffff) {
  386.         struct case_heap_entry temp;
  387.  
  388.         temp.key = (int) ZERO_AS_STR_CASE_LABEL;
  389.         temp.addr = zero_case_label;
  390.         temp.line = 0; /* if this is accessed later, something is
  391.                 * really wrong                  */
  392.         add_to_case_heap(A_CASE_STRINGS,&temp);
  393.         }
  394.     }
  395.     heap_start = mem_block[block_index].block + current_case_heap ;
  396.     heap_end_offs = mem_block[block_index].current_size -current_case_heap;
  397.     if (!heap_end_offs) yyerror("switch without case not supported");
  398.  
  399.         /* add a dummy entry so that we can always
  400.         * assume we have no or two childs
  401.         */
  402.         add_to_mem_block(block_index, "\0\0\0\0\0\0\0\0",
  403.             sizeof(struct case_heap_entry) );
  404.  
  405.         /* read out the heap and build a sorted table */
  406.     /* the table could be optimized better, but let's first see
  407.     * how much switch is used at all when it is full-featured...
  408.     */
  409.     mem_block[A_CASE_LABELS].current_size = 0;
  410.     lookup_start = 0;
  411.     lookup_start_key = ((struct case_heap_entry*)heap_start)->key;
  412.         for( ; ((struct case_heap_entry*)heap_start)->addr; )
  413.         {
  414.             int offset;
  415.         int curr_line,last_line;
  416.         unsigned short current_addr,last_addr = 0xffff;
  417.         int range_start;
  418.  
  419.             current_key = ((struct case_heap_entry*)heap_start)->key ;
  420.             curr_line = ((struct case_heap_entry*)heap_start)->line ;
  421.             current_addr = ((struct case_heap_entry*)heap_start)->addr ;
  422.             if ( current_key == last_key &&
  423.               mem_block[A_CASE_LABELS].current_size )
  424.             {
  425.                 char buf[90];
  426.  
  427.                 sprintf(buf,"Duplicate case in line %d and %d",
  428.             last_line, curr_line);
  429.                 yyerror(buf);
  430.             }
  431.         if (curr_line) {
  432.         if (last_addr == 1) {
  433.                     char buf[120];
  434.     
  435.             sprintf(buf,
  436. "Discontinued case label list range, line %d by line %d",
  437.               last_line, curr_line);
  438.                     yyerror(buf);
  439.         }
  440.           else if (current_key == last_key + 1
  441.             && current_addr == last_addr) {
  442.             if (mem_block[A_CASE_LABELS].current_size
  443.               != range_start + 6) {
  444.               *(short*)(mem_block[A_CASE_LABELS].block+range_start+4)
  445.             =1;
  446.               mem_block[A_CASE_LABELS].current_size = range_start + 6;
  447.             }
  448.         } else {
  449.             range_start = mem_block[A_CASE_LABELS].current_size;
  450.         }
  451.         }
  452.             last_key = current_key;
  453.         last_line = curr_line;
  454.         last_addr = current_addr;
  455.         add_to_mem_block(A_CASE_LABELS,
  456.                 (char *)¤t_key, sizeof(long) );
  457.         add_to_mem_block(A_CASE_LABELS,
  458.         (char *)¤t_addr, sizeof(short) );
  459.             for ( offset = 0; ; )
  460.             {
  461.  
  462.                 int child1,child2;
  463.  
  464.                 child1 = ( offset << 1 ) + sizeof(struct case_heap_entry);
  465.                 child2 = child1 + sizeof(struct case_heap_entry);
  466.                 if ( child1 >= heap_end_offs ) break;
  467.                 if ( ((struct case_heap_entry*)(heap_start+child1))->addr &&
  468.                   ( !((struct case_heap_entry*)(heap_start+child2))->addr ||
  469.                    ((struct case_heap_entry*)(heap_start+child1))->key <=
  470.                    ((struct case_heap_entry*)(heap_start+child2))->key  ) )
  471.                 {
  472.                     *(struct case_heap_entry*)(heap_start+offset) =
  473.                     *(struct case_heap_entry*)(heap_start+child1);
  474.                     offset = child1;
  475.                 } else
  476.                     if (((struct case_heap_entry*)(heap_start+child2))->addr ) {
  477.                         *(struct case_heap_entry*)(heap_start+offset) =
  478.                         *(struct case_heap_entry*)(heap_start+child2);
  479.                         offset = child2;
  480.                     } else break;
  481.             }
  482.             ((struct case_heap_entry*)(heap_start+offset))->addr = 0;
  483.         }
  484.  
  485.     /* write start of table */
  486.         upd_short(current_break_address-2,
  487.             mem_block[A_PROGRAM].current_size);
  488.  
  489.     add_to_mem_block(A_PROGRAM, mem_block[A_CASE_LABELS].block,
  490.             mem_block[A_CASE_LABELS].current_size );
  491.         /* calculate starting index for itarative search at execution time */
  492.         for(i=0xf0,o=6; o<<1 <= mem_block[A_CASE_LABELS].current_size; )
  493.             i++,o<<=1;
  494.         if (block_index == A_CASE_STRINGS) i = ( i << 4 ) | 0xf;
  495.         /* and store it */
  496.         mem_block[A_PROGRAM].block[current_break_address-3] &= i;
  497. #if 0  /* neither the code for ordinary switch is fully debugged now,
  498.     * nor is the code for packed switch tables complete */
  499.     d = ((struct case_heap_entry*)heap_start)->key;
  500.     if ( (r-d)*sizeof(short) < heap_end_offs ) {
  501.         mem_block[A_PROGRAM].block[current_break_address-3] &= 0xfe;
  502.             upd_short(current_break_address-2, mem_block[A_PROGRAM].current_size);
  503.             size_without_table = mem_block[A_PROGRAM].current_size;
  504.         r = heap_end_offs / sizeof(struct case_heap_entry);
  505.         add_to_mem_block(A_PROGRAM,mem_block[A_PROGRAM]->block,
  506.         r * sizeof(short) );
  507.         memset(mem_block[A_PROGRAM]->block+size_without_table,
  508.         '\0',r * sizeof(short) );
  509.         ins_long( d );
  510.         for(; --r; heap_start += sizeof(struct case_heap_entry) )
  511.         {
  512.         upd_short(size_without_table + sizeof(short)*
  513.                     ( ((struct case_heap_entry*)heap_start)->key - d )
  514.           , ((struct case_heap_entry*)heap_start)->addr );
  515.         }
  516.         }
  517. #endif /* 0 */
  518.     upd_short(current_break_address, mem_block[A_PROGRAM].current_size);
  519.     
  520.     mem_block[A_CASE_NUMBERS].current_size = current_case_number_heap;
  521.     mem_block[A_CASE_STRINGS].current_size = current_case_string_heap;
  522.         current_break_address = pop_address();
  523.     zero_case_label = pop_address();
  524.         current_case_string_heap = pop_address();
  525.         current_case_number_heap = pop_address();
  526.         current_break_stack_need -= sizeof(short);
  527.     } ;
  528.  
  529. case: F_CASE case_label ':'
  530.     {
  531.     struct case_heap_entry temp;
  532.  
  533.     if ( !( current_break_address & BREAK_FROM_CASE ) ) {
  534.         yyerror("Case outside switch");
  535.         break;
  536.     }
  537.     temp.key = $2.key;
  538.     temp.addr = mem_block[A_PROGRAM].current_size;
  539.     temp.line = current_line;
  540.     add_to_case_heap($2.block,&temp);
  541.     }
  542.     | F_CASE case_label F_RANGE case_label ':'
  543.     {
  544.     struct case_heap_entry temp;
  545.  
  546.     if ( $2.block != A_CASE_NUMBERS || $4.block != A_CASE_NUMBERS )
  547.         yyerror("String case labels not allowed as range bounds");
  548.     if ($2.key > $4.key) break;
  549.     temp.key = $2.key;
  550.     temp.addr = 1;
  551.     temp.line = current_line;
  552.     add_to_case_heap(A_CASE_NUMBERS,&temp);
  553.     temp.key = $4.key;
  554.     temp.addr = mem_block[A_PROGRAM].current_size;
  555.     temp.line = 0;
  556.     add_to_case_heap(A_CASE_NUMBERS,&temp);
  557.     } ;
  558.     
  559. case_label: constant
  560.         {
  561.         if ( !(zero_case_label & NO_STRING_CASE_LABELS) )
  562.         yyerror("Mixed case label list not allowed");
  563.         if ( $$.key = $1 )
  564.             zero_case_label |= SOME_NUMERIC_CASE_LABELS;
  565.         else
  566.         zero_case_label |= mem_block[A_PROGRAM].current_size;
  567.         $$.block = A_CASE_NUMBERS;
  568.     }
  569.       | string_constant
  570.         {
  571.         if ( zero_case_label & SOME_NUMERIC_CASE_LABELS )
  572.         yyerror("Mixed case label list not allowed");
  573.         zero_case_label &= ~NO_STRING_CASE_LABELS;
  574.             store_prog_string($1);
  575.             $$.key = (int)$1;
  576.         $$.block = A_CASE_STRINGS;
  577.         }
  578.       ;
  579.  
  580. constant: const1
  581.     | constant '|' const1 { $$ = $1 | $3; } ;
  582.  
  583. const1: const2
  584.       | const1 '^' const2 { $$ = $1 ^ $3; } ;
  585.  
  586. const2: const3
  587.       | const2 '&' const3 { $$ = $1 & $3; } ;
  588.  
  589. const3: const4
  590.       | const3 F_EQ const4 { $$ = $1 == $3; }
  591.       | const3 F_NE const4 { $$ = $1 != $3; } ;
  592.  
  593. const4: const5
  594.       | const4 '>'  const5 { $$ = $1 >  $3; }
  595.       | const4 F_GE const5 { $$ = $1 >= $3; }
  596.       | const4 '<'  const5 { $$ = $1 <  $3; }
  597.       | const4 F_LE const5 { $$ = $1 <= $3; } ;
  598.  
  599. const5: const6
  600.       | const5 F_LSH const6 { $$ = $1 << $3; }
  601.       | const5 F_RSH const6 { $$ = $1 >> $3; } ;
  602.  
  603. const6: const7
  604.       | const6 '+' const7 { $$ = $1 + $3; }
  605.       | const6 '-' const7 { $$ = $1 - $3; } ;
  606.  
  607. const7: const8
  608.       | const7 '*' const8 { $$ = $1 * $3; }
  609.       | const7 '%' const8 { $$ = $1 % $3; }
  610.       | const7 '/' const8 { $$ = $1 / $3; } ;
  611.  
  612. const8: const9
  613.       | '(' constant ')' { $$ = $2; } ;
  614.  
  615. const9: F_NUMBER
  616.       | '-'   F_NUMBER { $$ = -$2; }
  617.       | F_NOT F_NUMBER { $$ = !$2; }
  618.       | '~'   F_NUMBER { $$ = ~$2; } ;
  619.  
  620. default: F_DEFAULT ':'
  621.     {
  622.     if ( !( current_break_address & BREAK_FROM_CASE ) ) {
  623.         yyerror("Default outside switch");
  624.         break;
  625.     }
  626.     current_break_address &= ~(BREAK_ON_STACK|BREAK_FROM_CASE);
  627.     if ( read_short(current_break_address+2 ) )
  628.         yyerror("Duplicate default");
  629.     upd_short(current_break_address+2, mem_block[A_PROGRAM].current_size);
  630.     current_break_address |= (BREAK_ON_STACK|BREAK_FROM_CASE);
  631.     } ;
  632.  
  633.  
  634. comma_expr: expr0 { $$ = $1; }
  635.           | comma_expr { ins_f_byte(F_POP_VALUE); }
  636.     ',' expr0
  637.     { $$ = $4; } ;
  638.  
  639. expr0:  expr01
  640.      | lvalue assign expr0
  641.     {
  642.         if (exact_types && !compatible_types($1, $3) &&
  643.         !($1 == TYPE_STRING && $3 == TYPE_NUMBER && $2 == F_ADD_EQ))
  644.         {
  645.         type_error("Bad assignment. Rhs", $3);
  646.         }
  647.         ins_f_byte($2);
  648.         $$ = $3;
  649.     }
  650.      | error assign expr01 { yyerror("Illegal LHS");  $$ = TYPE_ANY; };
  651.  
  652. expr01: expr1 { $$ = $1; }
  653.      | expr1 '?'
  654.     {
  655.         ins_f_byte(F_JUMP_WHEN_ZERO);
  656.         push_address();
  657.         ins_short(0);
  658.     }
  659.       expr01
  660.     {
  661.         int i;
  662.         i = pop_address();
  663.         ins_f_byte(F_JUMP); push_address(); ins_short(0);
  664.         upd_short(i, mem_block[A_PROGRAM].current_size);
  665.     }
  666.       ':' expr01
  667.     {
  668.         upd_short(pop_address(), mem_block[A_PROGRAM].current_size);
  669.         if (exact_types && !compatible_types($4, $7)) {
  670.         type_error("Different types in ?: expr", $4);
  671.         type_error("                      and ", $7);
  672.         }
  673.         if ($4 == TYPE_ANY) $$ = $7;
  674.         else if ($7 == TYPE_ANY) $$ = $4;
  675.         else if (TYPE($4, TYPE_MOD_POINTER|TYPE_ANY)) $$ = $7;
  676.         else if (TYPE($7, TYPE_MOD_POINTER|TYPE_ANY)) $$ = $4;
  677.         else $$ = $4;
  678.     };
  679.  
  680. assign: '=' { $$ = F_ASSIGN; }
  681.       | F_AND_EQ { $$ = F_AND_EQ; }
  682.       | F_OR_EQ { $$ = F_OR_EQ; }
  683.       | F_XOR_EQ { $$ = F_XOR_EQ; }
  684.       | F_LSH_EQ { $$ = F_LSH_EQ; }
  685.       | F_RSH_EQ { $$ = F_RSH_EQ; }
  686.       | F_ADD_EQ { $$ = F_ADD_EQ; }
  687.       | F_SUB_EQ { $$ = F_SUB_EQ; }
  688.       | F_MULT_EQ { $$ = F_MULT_EQ; }
  689.       | F_MOD_EQ { $$ = F_MOD_EQ; }
  690.       | F_DIV_EQ { $$ = F_DIV_EQ; };
  691.  
  692. return: F_RETURN
  693.     {
  694.         if (exact_types && !TYPE(exact_types, TYPE_VOID))
  695.         type_error("Must return a value for a function declared",
  696.                exact_types);
  697.         ins_f_byte(F_CONST0);
  698.         ins_f_byte(F_RETURN);
  699.     }
  700.       | F_RETURN comma_expr
  701.     {
  702.         if (exact_types && !TYPE($2, exact_types & TYPE_MOD_MASK))
  703.         type_error("Return type not matching", exact_types);
  704.         ins_f_byte(F_RETURN);
  705.     };
  706.  
  707. expr_list: /* empty */        { $$ = 0; }
  708.      | expr_list2        { $$ = $1; }
  709.      | expr_list2 ','    { $$ = $1; } ; /* Allow a terminating comma */
  710.  
  711. expr_list2: expr0        { $$ = 1; add_arg_type($1); }
  712.          | expr_list2 ',' expr0    { $$ = $1 + 1; add_arg_type($3); } ;
  713.  
  714. m_expr_list: /* empty */    { $$ = 0; }
  715.      | m_expr_list2        { $$ = $1; }
  716.      | m_expr_list2 ','    { $$ = $1; } ; /* Allow a terminating comma */
  717.  
  718. m_expr_list2: expr0 ':' expr1    { $$ = 2; add_arg_type($1); add_arg_type($3); }
  719.      | m_expr_list2 ',' expr0 ':' expr1 { $$ = $1 + 2; add_arg_type($3); add_arg_type($5); }
  720.  
  721. expr1: expr2 { $$ = $1; }
  722.      | expr2 F_LOR
  723.     {
  724.         ins_f_byte(F_DUP); ins_f_byte(F_JUMP_WHEN_NON_ZERO);
  725.         push_address();
  726.         ins_short(0);
  727.         ins_f_byte(F_POP_VALUE);
  728.     }
  729.        expr1
  730.     {
  731.         upd_short(pop_address(), mem_block[A_PROGRAM].current_size);
  732.         if ($1 == $4)
  733.         $$ = $1;
  734.         else
  735.         $$ = TYPE_ANY;    /* Return type can't be known */
  736.     };
  737.  
  738. expr2: expr211 { $$ = $1; }
  739.      | expr211 F_LAND
  740.     {
  741.         ins_f_byte(F_DUP); ins_f_byte(F_JUMP_WHEN_ZERO);
  742.         push_address();
  743.         ins_short(0);
  744.         ins_f_byte(F_POP_VALUE);
  745.     }
  746.        expr2
  747.     {
  748.         upd_short(pop_address(), mem_block[A_PROGRAM].current_size);
  749.         if ($1 == $4)
  750.         $$ = $1;
  751.         else
  752.         $$ = TYPE_ANY;    /* Return type can't be known */
  753.     } ;
  754.  
  755. expr211: expr212
  756.        | expr211 '|' expr212
  757.           {
  758.           if (exact_types && !TYPE($1,TYPE_NUMBER))
  759.           type_error("Bad argument 1 to |", $1);
  760.           if (exact_types && !TYPE($3,TYPE_NUMBER))
  761.           type_error("Bad argument 2 to |", $3);
  762.           $$ = TYPE_NUMBER;
  763.           ins_f_byte(F_OR);
  764.       };
  765.  
  766. expr212: expr213
  767.        | expr212 '^' expr213
  768.       {
  769.           if (exact_types && !TYPE($1,TYPE_NUMBER))
  770.           type_error("Bad argument 1 to ^", $1);
  771.           if (exact_types && !TYPE($3,TYPE_NUMBER))
  772.           type_error("Bad argument 2 to ^", $3);
  773.           $$ = TYPE_NUMBER;
  774.           ins_f_byte(F_XOR);
  775.       };
  776.  
  777. expr213: expr22
  778.        | expr213 '&' expr22
  779.       {
  780.           ins_f_byte(F_AND);
  781.           if ( !TYPE($1,TYPE_MOD_POINTER) || !TYPE($3,TYPE_MOD_POINTER) ) {
  782.               if (exact_types && !TYPE($1,TYPE_NUMBER))
  783.               type_error("Bad argument 1 to &", $1);
  784.               if (exact_types && !TYPE($3,TYPE_NUMBER))
  785.               type_error("Bad argument 2 to &", $3);
  786.           }
  787.           $$ = TYPE_NUMBER;
  788.       };
  789.  
  790. expr22: expr23
  791.       | expr24 F_EQ expr24
  792.     {
  793.         int t1 = $1 & TYPE_MOD_MASK, t2 = $3 & TYPE_MOD_MASK;
  794.         if (exact_types && t1 != t2 && t1 != TYPE_ANY && t2 != TYPE_ANY) {
  795.         type_error("== always false because of different types", $1);
  796.         type_error("                               compared to", $3);
  797.         }
  798.         ins_f_byte(F_EQ);
  799.         $$ = TYPE_NUMBER;
  800.     };
  801.       | expr24 F_NE expr24
  802.     {
  803.         int t1 = $1 & TYPE_MOD_MASK, t2 = $3 & TYPE_MOD_MASK;
  804.         if (exact_types && t1 != t2 && t1 != TYPE_ANY && t2 != TYPE_ANY) {
  805.         type_error("!= always true because of different types", $1);
  806.         type_error("                               compared to", $3);
  807.         }
  808.         ins_f_byte(F_NE);
  809.         $$ = TYPE_NUMBER;
  810.     };
  811.  
  812. expr23: expr24
  813.       | expr24 '>' expr24
  814.     { $$ = TYPE_NUMBER; ins_f_byte(F_GT); };
  815.       | expr24 F_GE expr24
  816.     { $$ = TYPE_NUMBER; ins_f_byte(F_GE); };
  817.       | expr24 '<' expr24
  818.     { $$ = TYPE_NUMBER; ins_f_byte(F_LT); };
  819.       | expr24 F_LE expr24
  820.     { $$ = TYPE_NUMBER; ins_f_byte(F_LE); };
  821.  
  822. expr24: expr25
  823.       | expr24 F_LSH expr25
  824.     {
  825.         ins_f_byte(F_LSH);
  826.         $$ = TYPE_NUMBER;
  827.         if (exact_types && !TYPE($1, TYPE_NUMBER))
  828.         type_error("Bad argument number 1 to '<<'", $1);
  829.         if (exact_types && !TYPE($3, TYPE_NUMBER))
  830.         type_error("Bad argument number 2 to '<<'", $3);
  831.     };
  832.       | expr24 F_RSH expr25
  833.     {
  834.         ins_f_byte(F_RSH);
  835.         $$ = TYPE_NUMBER;
  836.         if (exact_types && !TYPE($1, TYPE_NUMBER))
  837.         type_error("Bad argument number 1 to '>>'", $1);
  838.         if (exact_types && !TYPE($3, TYPE_NUMBER))
  839.         type_error("Bad argument number 2 to '>>'", $3);
  840.     };
  841.  
  842. expr25: expr27
  843.       | expr25 '+' expr27    /* Type checks of this case is complicated */
  844.     { ins_f_byte(F_ADD); $$ = TYPE_ANY; };
  845.       | expr25 '-' expr27
  846.     {
  847.         int bad_arg = 0;
  848.  
  849.         if (exact_types) {
  850.         if (!TYPE($1, TYPE_NUMBER) && !($1 & TYPE_MOD_POINTER) ) {
  851.                     type_error("Bad argument number 1 to '-'", $1);
  852.             bad_arg++;
  853.         }
  854.         if (!TYPE($3, TYPE_NUMBER) && !($3 & TYPE_MOD_POINTER) ) {
  855.                     type_error("Bad argument number 2 to '-'", $3);
  856.             bad_arg++;
  857.         }
  858.         }
  859.         $$ = TYPE_ANY;
  860.         if (($1 & TYPE_MOD_POINTER) || ($3 & TYPE_MOD_POINTER))
  861.         $$ = TYPE_MOD_POINTER | TYPE_ANY;
  862.         if (!($1 & TYPE_MOD_POINTER) || !($3 & TYPE_MOD_POINTER)) {
  863.         if (exact_types && $$ != TYPE_ANY && !bad_arg)
  864.             yyerror("Arguments to '-' don't match");
  865.         $$ = TYPE_NUMBER;
  866.         }
  867.         ins_f_byte(F_SUBTRACT);
  868.     };
  869.  
  870. expr27: expr28
  871.       | expr27 '*' expr3
  872.     {
  873.         if (exact_types && !TYPE($1, TYPE_NUMBER))
  874.         type_error("Bad argument number 1 to '*'", $1);
  875.         if (exact_types && !TYPE($3, TYPE_NUMBER))
  876.         type_error("Bad argument number 2 to '*'", $3);
  877.         ins_f_byte(F_MULTIPLY);
  878.         $$ = TYPE_NUMBER;
  879.     };
  880.       | expr27 '%' expr3
  881.     {
  882.         if (exact_types && !TYPE($1, TYPE_NUMBER))
  883.         type_error("Bad argument number 1 to '%'", $1);
  884.         if (exact_types && !TYPE($3, TYPE_NUMBER))
  885.         type_error("Bad argument number 2 to '%'", $3);
  886.         ins_f_byte(F_MOD);
  887.         $$ = TYPE_NUMBER;
  888.     };
  889.       | expr27 '/' expr3
  890.     {
  891.         if (exact_types && !TYPE($1, TYPE_NUMBER))
  892.         type_error("Bad argument number 1 to '/'", $1);
  893.         if (exact_types && !TYPE($3, TYPE_NUMBER))
  894.         type_error("Bad argument number 2 to '/'", $3);
  895.         ins_f_byte(F_DIVIDE);
  896.         $$ = TYPE_NUMBER;
  897.     };
  898.  
  899. expr28: expr3
  900.     | cast expr3
  901.           {
  902.           $$ = $1;
  903.           if (exact_types && $2 != TYPE_ANY && $2 != TYPE_UNKNOWN &&
  904.               $1 != TYPE_VOID)
  905.               type_error("Casts are only legal for type mixed, or when unknown", $2);
  906.           } ;
  907.  
  908. expr3: expr31
  909.      | F_INC lvalue
  910.         {
  911.         ins_f_byte(F_INC);
  912.         if (exact_types && !TYPE($2, TYPE_NUMBER))
  913.         type_error("Bad argument to ++", $2);
  914.         $$ = TYPE_NUMBER;
  915.     };
  916.      | F_DEC lvalue
  917.         {
  918.         ins_f_byte(F_DEC);
  919.         if (exact_types && !TYPE($2, TYPE_NUMBER))
  920.         type_error("Bad argument to --", $2);
  921.         $$ = TYPE_NUMBER;
  922.     };
  923.      | F_NOT expr3
  924.     {
  925.         ins_f_byte(F_NOT);    /* Any type is valid here. */
  926.         $$ = TYPE_NUMBER;
  927.     };
  928.      | '~' expr3
  929.     {
  930.         ins_f_byte(F_COMPL);
  931.         if (exact_types && !TYPE($2, TYPE_NUMBER))
  932.         type_error("Bad argument to ~", $2);
  933.         $$ = TYPE_NUMBER;
  934.     };
  935.      | '-' expr3
  936.     {
  937.         ins_f_byte(F_NEGATE);
  938.         if (exact_types && !TYPE($2, TYPE_NUMBER))
  939.         type_error("Bad argument to unary '-'", $2);
  940.         $$ = TYPE_NUMBER;
  941.     };
  942.  
  943. expr31: expr4
  944.       | lvalue F_INC
  945.          {
  946.          ins_f_byte(F_POST_INC);
  947.          if (exact_types && !TYPE($1, TYPE_NUMBER))
  948.          type_error("Bad argument to ++", $1);
  949.          $$ = TYPE_NUMBER;
  950.      };
  951.       | lvalue F_DEC
  952.          {
  953.          ins_f_byte(F_POST_DEC);
  954.          if (exact_types && !TYPE($1, TYPE_NUMBER))
  955.          type_error("Bad argument to --", $1);
  956.          $$ = TYPE_NUMBER;
  957.      };
  958.  
  959. expr4: function_call
  960.      | lvalue
  961.     {
  962.         int pos = mem_block[A_PROGRAM].current_size;
  963.         /* Some optimization. Replace the push-lvalue with push-value */
  964.         if (last_push_identifier == pos-2)
  965.         mem_block[A_PROGRAM].block[last_push_identifier] =
  966.             F_IDENTIFIER - F_OFFSET;
  967.         else if (last_push_local == pos-2)
  968.         mem_block[A_PROGRAM].block[last_push_local] =
  969.             F_LOCAL_NAME - F_OFFSET;
  970.         else if (last_push_indexed == pos-1)
  971.         mem_block[A_PROGRAM].block[last_push_indexed] =
  972.             F_INDEX - F_OFFSET;
  973.         else if (last_push_indexed != 0)
  974.         fatal("Should be a push at this point !\n");
  975.         $$ = $1;
  976.     }
  977.      | string | number
  978.      | '(' comma_expr ')' { $$ = $2; }
  979.      | catch { $$ = TYPE_ANY; }
  980.      | sscanf { $$ = TYPE_NUMBER; }
  981.      | parse_command { $$ = TYPE_NUMBER; }
  982.      | '(' '{' expr_list '}' ')'
  983.        {
  984.        pop_arg_stack($3);        /* We don't care about these types */
  985.        ins_f_byte(F_AGGREGATE);
  986.        ins_short($3);
  987.        $$ = TYPE_MOD_POINTER | TYPE_ANY;
  988.        }
  989.      | '(' '[' m_expr_list ']' ')'
  990.        {
  991.        pop_arg_stack($3);
  992.        ins_f_byte(F_M_AGGREGATE);
  993.        ins_short($3);
  994.        $$ = TYPE_MAPPING;
  995.        };
  996.  
  997. catch: F_CATCH { ins_f_byte(F_CATCH); push_address(); ins_short(0);}
  998.        '(' comma_expr ')'
  999.            {
  1000.            ins_f_byte(F_POP_VALUE);
  1001. #if 1
  1002.            ins_f_byte(F_CONST0);
  1003.            ins_f_byte(F_THROW);
  1004. #else
  1005.            ins_f_byte(F_RETURN);
  1006. #endif
  1007.            upd_short(pop_address(),
  1008.                  mem_block[A_PROGRAM].current_size);
  1009.            };
  1010.  
  1011. sscanf: F_SSCANF '(' expr0 ',' expr0 lvalue_list ')'
  1012.     {
  1013.         ins_f_byte(F_SSCANF); ins_byte($6 + 2);
  1014.     }
  1015.  
  1016. parse_command: F_PARSE_COMMAND '(' expr0 ',' expr0 ',' expr0 lvalue_list ')'
  1017.     {
  1018.         ins_f_byte(F_PARSE_COMMAND); ins_byte($8 + 3);
  1019.     }
  1020.  
  1021. lvalue_list: /* empty */ { $$ = 0; }
  1022.        | ',' lvalue lvalue_list { $$ = 1 + $3; } ;
  1023.  
  1024. lvalue: F_IDENTIFIER
  1025.     {
  1026.         int i = verify_declared($1);
  1027.         last_push_identifier = mem_block[A_PROGRAM].current_size;
  1028.         ins_f_byte(F_PUSH_IDENTIFIER_LVALUE);
  1029.         ins_byte(i);
  1030.         xfree($1);
  1031.         if (i == -1)
  1032.         $$ = TYPE_ANY;
  1033.         else
  1034.         $$ = VARIABLE(i)->type & TYPE_MOD_MASK;
  1035.     }
  1036.         | F_LOCAL_NAME
  1037.     {
  1038.         last_push_local = mem_block[A_PROGRAM].current_size;
  1039.         ins_f_byte(F_PUSH_LOCAL_VARIABLE_LVALUE);
  1040.         ins_byte($1);
  1041.         $$ = type_of_locals[$1];
  1042.     }
  1043.     | expr4 '[' comma_expr F_RANGE comma_expr ']'
  1044.       {
  1045.           ins_f_byte(F_RANGE);
  1046.           last_push_indexed = 0;
  1047.           if (exact_types) {
  1048.           if (($1 & TYPE_MOD_POINTER) == 0 && !TYPE($1, TYPE_STRING))
  1049.               type_error("Bad type to indexed value", $1);
  1050.           if (!TYPE($3, TYPE_NUMBER))
  1051.               type_error("Bad type of index", $3);
  1052.           if (!TYPE($5, TYPE_NUMBER))
  1053.               type_error("Bad type of index", $5);
  1054.           }
  1055.           if ($1 == TYPE_ANY)
  1056.           $$ = TYPE_ANY;
  1057.           else if (TYPE($1, TYPE_STRING))
  1058.           $$ = TYPE_STRING;
  1059.           else if ($1 & TYPE_MOD_POINTER)
  1060.           $$ = $1;
  1061.           else if (exact_types)
  1062.           type_error("Bad type of argument used for range", $1);
  1063.       };
  1064.     | expr4 '[' comma_expr ']'
  1065.       {
  1066.           last_push_indexed = mem_block[A_PROGRAM].current_size;
  1067.           ins_f_byte(F_PUSH_INDEXED_LVALUE);
  1068.           if (exact_types  && !($1 & TYPE_MAPPING)) {
  1069.           if (($1 & TYPE_MOD_POINTER) == 0 && !TYPE($1, TYPE_STRING))
  1070.               type_error("Bad type to indexed value", $1);
  1071.           if (!TYPE($3, TYPE_NUMBER))
  1072.               type_error("Bad type of index", $3);
  1073.           }
  1074.           if ($1 == TYPE_ANY)
  1075.           $$ = TYPE_ANY;
  1076.           else if (TYPE($1, TYPE_STRING))
  1077.           $$ = TYPE_NUMBER;
  1078.           else if ($1 == TYPE_MAPPING)
  1079.           $$ = TYPE_ANY;
  1080.           else
  1081.           $$ = $1 & TYPE_MOD_MASK & ~TYPE_MOD_POINTER;
  1082.       };
  1083.  
  1084. string: F_STRING
  1085.     {
  1086.         ins_f_byte(F_STRING);
  1087.         ins_short(store_prog_string($1));
  1088.         xfree($1);
  1089.         $$ = TYPE_STRING;
  1090.     };
  1091.  
  1092. string_constant: string_con1
  1093.         {
  1094.             char *p = make_shared_string($1);
  1095.             xfree($1);
  1096.             $$ = p;
  1097.         };
  1098.  
  1099. string_con1: F_STRING
  1100.        | string_con1 '+' F_STRING
  1101.     {
  1102.         $$ = xalloc( strlen($1) + strlen($3) + 1 );
  1103.         strcpy($$, $1);
  1104.         strcat($$, $3);
  1105.         xfree($1);
  1106.         xfree($3);
  1107.     };
  1108.  
  1109. function_call: function_name
  1110.     {
  1111.     /* This seems to be an ordinary function call. But, if the function
  1112.      * is not defined, then it might be a call to a simul_efun.
  1113.      * If it is, then we make it a call_other(), which requires the
  1114.      * function name as argument.
  1115.      * We have to remember until after parsing the arguments if it was
  1116.      * a simulated efun or not, which means that the pointer has to be
  1117.      * pushed on a stack. Use the internal yacc stack for this purpose.
  1118.      */
  1119.     $<funp>$ = 0;
  1120.     if (defined_function($1, 0) == -1) {
  1121.         char *p = make_shared_string($1);
  1122.         $<funp>$ = find_simul_efun(p);
  1123.         if ($<funp>$ && !($<funp>$->type & TYPE_MOD_STATIC)) {
  1124.         ins_f_byte(F_STRING);
  1125.         ins_short(store_prog_string(
  1126.                   query_simul_efun_file_name()));
  1127.         ins_f_byte(F_STRING);
  1128.         ins_short(store_prog_string(p));
  1129.         } else {
  1130.         $<funp>$ = 0;
  1131.         }
  1132.         free_string(p);
  1133.     }
  1134.     }
  1135.     '(' expr_list ')'
  1136.     { 
  1137.     int f;
  1138.     int efun_override = strncmp($1, "efun::", 6) == 0;
  1139.  
  1140.     if ($<funp>2) {
  1141.         ins_f_byte(F_CALL_OTHER);
  1142.         ins_byte($4 + 2);
  1143. #ifdef CACHE_CALL_OTHER
  1144.         ins_short(-1); 
  1145. #endif
  1146.         $$ = $<funp>2->type;
  1147.     } else if (!efun_override && (f = defined_function($1, 0)) >= 0) {
  1148.         struct function *funp;
  1149.         ins_f_byte(F_CALL_FUNCTION_BY_ADDRESS); ins_short(f);
  1150.         ins_byte($4);    /* Actual number of arguments */
  1151.         funp = FUNCTION(f);
  1152.         if (funp->flags & NAME_UNDEFINED)
  1153.         find_inherited(funp);
  1154.         /*
  1155.          * Verify that the function has been defined already.
  1156.          */
  1157.         if ((funp->flags & NAME_UNDEFINED) &&
  1158.         !(funp->flags & NAME_PROTOTYPE) && exact_types)
  1159.         {
  1160.         char buff[100];
  1161.         sprintf(buff, "Function %.50s undefined", funp->name);
  1162.         yyerror(buff);
  1163.         }
  1164.         $$ = funp->type & TYPE_MOD_MASK;
  1165.         /*
  1166.          * Check number of arguments.
  1167.          */
  1168.         if (funp->num_arg != $4 && !(funp->type & TYPE_MOD_VARARGS) &&
  1169.         (funp->flags & NAME_STRICT_TYPES) && exact_types)
  1170.         {
  1171.         char buff[100];
  1172.         sprintf(buff, "Wrong number of arguments to %.60s", $1);
  1173.         yyerror(buff);
  1174.         }
  1175.         /*
  1176.          * Check the argument types.
  1177.          */
  1178.         if (exact_types && *(unsigned short *)&mem_block[A_ARGUMENT_INDEX].block[f * sizeof (unsigned short)] != INDEX_START_NONE)
  1179.         {
  1180.         int i, first;
  1181.         unsigned short *arg_types;
  1182.         
  1183.         arg_types = (unsigned short *)
  1184.             mem_block[A_ARGUMENT_TYPES].block;
  1185.         first = *(unsigned short *)&mem_block[A_ARGUMENT_INDEX].block[f * sizeof (unsigned short)];
  1186.         for (i=0; i < funp->num_arg && i < $4; i++) {
  1187.             int tmp = get_argument_type(i, $4);
  1188.             if (!TYPE(tmp, arg_types[first + i])) {
  1189.             char buff[100];
  1190.             sprintf(buff, "Bad type for argument %d %s", i+1,
  1191.                 get_two_types(arg_types[first+i], tmp));
  1192.             yyerror(buff);
  1193.             }
  1194.         }
  1195.         }
  1196.     } else if (efun_override || (f = lookup_predef($1)) != -1) {
  1197.         int min, max, def, *argp;
  1198.         extern int efun_arg_types[];
  1199.  
  1200.         if (efun_override) {
  1201.         f = lookup_predef($1+6);
  1202.         }
  1203.         if (f == -1) {    /* Only possible for efun_override */
  1204.         char buff[100];
  1205.         sprintf(buff, "Unknown efun: %s", $1+6);
  1206.         yyerror(buff);
  1207.         } else {
  1208.         min = instrs[f-F_OFFSET].min_arg;
  1209.         max = instrs[f-F_OFFSET].max_arg;
  1210.         def = instrs[f-F_OFFSET].Default;
  1211.         $$ = instrs[f-F_OFFSET].ret_type;
  1212.         argp = &efun_arg_types[instrs[f-F_OFFSET].arg_index];
  1213.         if (def && $4 == min-1) {
  1214.             ins_f_byte(def);
  1215.             max--;
  1216.             min--;
  1217.         } else if ($4 < min) {
  1218.             char bff[100];
  1219.             sprintf(bff, "Too few arguments to %s",
  1220.                 instrs[f-F_OFFSET].name);
  1221.             yyerror(bff);
  1222.         } else if ($4 > max && max != -1) {
  1223.             char bff[100];
  1224.             sprintf(bff, "Too many arguments to %s",
  1225.                 instrs[f-F_OFFSET].name);
  1226.             yyerror(bff);
  1227.         } else if (max != -1 && exact_types) {
  1228.             /*
  1229.              * Now check all types of the arguments to efuns.
  1230.              */
  1231.             int i, argn;
  1232.             char buff[100];
  1233.             for (argn=0; argn < $4; argn++) {
  1234.             int tmp = get_argument_type(argn, $4);
  1235.             for(i=0; !TYPE(argp[i], tmp) && argp[i] != 0; i++)
  1236.                 ;
  1237.             if (argp[i] == 0) {
  1238.                 sprintf(buff, "Bad argument %d type to efun %s()",
  1239.                     argn+1, instrs[f-F_OFFSET].name);
  1240.                 yyerror(buff);
  1241.             }
  1242.             while(argp[i] != 0)
  1243.                 i++;
  1244.             argp += i + 1;
  1245.             }
  1246.         }
  1247.         ins_f_byte(f);
  1248.         /* Only store number of arguments for instructions
  1249.          * that allowed a variable number.
  1250.          */
  1251.         if (max != min)
  1252.             ins_byte($4);/* Number of actual arguments */
  1253. #ifdef CACHE_CALL_OTHER
  1254.         if (f == F_CALL_OTHER)
  1255.             ins_short(-1); 
  1256. #endif
  1257.         }
  1258.     } else {
  1259.         struct function *funp;
  1260.  
  1261.         f = define_new_function($1, 0, 0, 0, NAME_UNDEFINED, 0);
  1262.         ins_f_byte(F_CALL_FUNCTION_BY_ADDRESS);
  1263.         ins_short(f);
  1264.         ins_byte($4);    /* Number of actual arguments */
  1265.         funp = FUNCTION(f);
  1266.         if (strchr($1, ':')) {
  1267.         /*
  1268.          * A function defined by inheritance. Find
  1269.          * real definition immediately.
  1270.          */
  1271.         find_inherited(funp);
  1272.         }
  1273.         /*
  1274.          * Check if this function has been defined.
  1275.          * But, don't complain yet about functions defined
  1276.          * by inheritance.
  1277.          */
  1278.         if (exact_types && (funp->flags & NAME_UNDEFINED)) {
  1279.         char buff[100];
  1280.         sprintf(buff, "Undefined function %.50s", $1);
  1281.         yyerror(buff);
  1282.         }
  1283.         if (!(funp->flags & NAME_UNDEFINED))
  1284.         $$ = funp->type & TYPE_MOD_MASK;
  1285.         else
  1286.         $$ = TYPE_ANY;    /* Just a guess */
  1287.     }
  1288.     xfree($1);
  1289.     pop_arg_stack($4);    /* Argument types not needed more */
  1290.     }
  1291. | expr4 F_ARROW function_name
  1292.     {
  1293.     ins_f_byte(F_STRING);
  1294.     ins_short(store_prog_string($3));
  1295.     xfree($3);
  1296.     }
  1297. '(' expr_list ')'
  1298.     {
  1299.     ins_f_byte(F_CALL_OTHER);
  1300.     ins_byte($6 + 2);
  1301.     $$ = TYPE_UNKNOWN;
  1302.  
  1303. #ifdef CACHE_CALL_OTHER
  1304.     ins_short(-1);
  1305. #endif
  1306.  
  1307.     pop_arg_stack($6);    /* No good need of these arguments */
  1308.     };
  1309.  
  1310. function_name: any_ident
  1311.          | F_COLON_COLON any_ident
  1312.         {
  1313.             char *p = xalloc(strlen($2) + 3);
  1314.             strcpy(p, "::"); strcat(p, $2); xfree($2);
  1315.             $$ = p;
  1316.         }
  1317.           | any_ident F_COLON_COLON any_ident
  1318.         {
  1319.             char *p = xalloc(strlen($1) + strlen($3) + 3);
  1320.             strcpy(p, $1); strcat(p, "::"); strcat(p, $3);
  1321.             xfree($1); xfree($3);
  1322.             $$ = p;
  1323.         };
  1324.  
  1325. any_ident: F_LOCAL_NAME
  1326.         {
  1327.             char *p = xalloc(strlen(local_names[$1]) + 1);
  1328.             strcpy(p, local_names[$1]);
  1329.             $$ = p;
  1330.         }
  1331.      | F_IDENTIFIER
  1332.           ;
  1333.  
  1334. cond: condStart
  1335.       statement
  1336.     {
  1337.         int i;
  1338.         i = pop_address();
  1339.         ins_f_byte(F_JUMP); push_address(); ins_short(0);
  1340.         upd_short(i, mem_block[A_PROGRAM].current_size);
  1341.     }
  1342.       optional_else_part
  1343.     { upd_short(pop_address(), mem_block[A_PROGRAM].current_size); } ;
  1344.  
  1345. condStart: F_IF '(' comma_expr ')'
  1346.     {
  1347.         ins_f_byte(F_JUMP_WHEN_ZERO);
  1348.         push_address();
  1349.         ins_short(0);
  1350.     } ;
  1351.  
  1352. optional_else_part: /* empty */
  1353.        | F_ELSE statement ;
  1354. %%
  1355.  
  1356. void yyerror(str)
  1357. char *str;
  1358. {
  1359.     extern int num_parse_error;
  1360.  
  1361.     if (num_parse_error > 5)
  1362.     return;
  1363.     (void)fprintf(stderr, "%s: %s line %d\n", current_file, str,
  1364.           current_line);
  1365.     fflush(stderr);
  1366.     smart_log(current_file, current_line, str);
  1367.     if (num_parse_error == 0)
  1368.     save_error(str, current_file, current_line);
  1369.     num_parse_error++;
  1370. }
  1371.  
  1372. static int check_declared(str)
  1373.     char *str;
  1374. {
  1375.     struct variable *vp;
  1376.     int offset;
  1377.  
  1378.     char * interned;
  1379.     extern char* findstring PROT((char*));
  1380.   
  1381.     if (interned = findstring(str)) /* Only search if amongst strings */
  1382.         for (offset=mem_block[A_VARIABLES].current_size-sizeof(struct variable);
  1383.          offset >= 0;
  1384.          offset -= sizeof (struct variable))
  1385.     {
  1386.         vp = (struct variable *)&mem_block[A_VARIABLES].block[offset];
  1387.         if (vp->flags & NAME_HIDDEN)
  1388.             continue;
  1389.         /* Pointer comparison is possible since we use unique strings */
  1390.         if (vp->name == interned)
  1391.             return offset / sizeof (struct variable);
  1392.     }
  1393.     return -1;
  1394. }
  1395.  
  1396. static int verify_declared(str)
  1397.     char *str;
  1398. {
  1399.     int r;
  1400.  
  1401.     r = check_declared(str);
  1402.     if (r < 0) {
  1403.     char buff[100];
  1404.         (void)sprintf(buff, "Variable %s not declared !", str);
  1405.         yyerror(buff);
  1406.     return -1;
  1407.     }
  1408.     return r;
  1409. }
  1410.  
  1411. void free_all_local_names()
  1412. {
  1413.     int i;
  1414.  
  1415.     for (i=0; i<current_number_of_locals; i++) {
  1416.     xfree(local_names[i]);
  1417.     local_names[i] = 0;
  1418.     }
  1419.     current_number_of_locals = 0;
  1420.     current_break_stack_need = 0;
  1421.     max_break_stack_need = 0;
  1422. }
  1423.  
  1424. void add_local_name(str, type)
  1425.     char *str;
  1426.     int type;
  1427. {
  1428.     if (current_number_of_locals == MAX_LOCAL)
  1429.     yyerror("Too many local variables");
  1430.     else {
  1431.     type_of_locals[current_number_of_locals] = type;
  1432.     local_names[current_number_of_locals++] = str;
  1433.     }
  1434. }
  1435.  
  1436. /*
  1437.  * Copy all function definitions from an inherited object. They are added
  1438.  * as undefined, so that they can be redefined by a local definition.
  1439.  * If they are not redefined, then they will be updated, so that they
  1440.  * point to the inherited definition. See epilog(). Types will be copied
  1441.  * at that moment (if available).
  1442.  *
  1443.  * A call to an inherited function will not be
  1444.  * done through this entry (because this entry can be replaced by a new
  1445.  * definition). If an function defined by inheritance is called, then one
  1446.  * special definition will be made at first call.
  1447.  */
  1448. static int copy_functions(from, type)
  1449.     struct program *from;
  1450.     int type;
  1451. {
  1452.     int i, initializer = -1;
  1453.     unsigned short tmp_short;
  1454.  
  1455.     for (i=0; i < from->num_functions; i++) {
  1456.     /* Do not call define_new_function() from here, as duplicates would
  1457.      * be removed.
  1458.      */
  1459.     struct function fun;
  1460.     int new_type, n;
  1461.  
  1462.     fun = from->functions[i];    /* Make a copy */
  1463.     /* Prepare some data to be used if this function will not be
  1464.      * redefined.
  1465.      */
  1466.     if (strchr(fun.name, ':') || fun.type & TYPE_MOD_PRIVATE)
  1467.         fun.flags |= NAME_HIDDEN;    /* Not to be used again ! */
  1468.     if (fun.type & TYPE_MOD_PRIVATE)
  1469.         fun.flags |= NAME_INHERITED;
  1470.     fun.name = make_shared_string(fun.name);    /* Incr ref count */
  1471.     fun.offset = mem_block[A_INHERITS].current_size /
  1472.         sizeof (struct inherit) - 1;
  1473.     fun.function_index_offset = i;
  1474.     if ((n = defined_function(fun.name, 0)) >= 0) {
  1475.         struct function *funp;
  1476.  
  1477.         funp = &((struct function *)mem_block[A_FUNCTIONS].block)[n];
  1478.         if (((fun.type & TYPE_MOD_NO_MASK) &&
  1479.            !(funp->flags & NAME_UNDEFINED) &&
  1480.            !(fun.type & TYPE_MOD_PRIVATE)) ||
  1481.  
  1482.             (funp->type & TYPE_MOD_NO_MASK) &&
  1483.            !(fun.type & TYPE_MOD_PRIVATE) &&
  1484.            !(funp->flags & NAME_UNDEFINED))
  1485.         {
  1486.         char *p = (char *)alloca(80 + strlen(fun.name));
  1487.         sprintf(p, "Illegal to redefine 'nomask' function \"%s\"",
  1488.             fun.name);
  1489.         yyerror(p);
  1490.         }
  1491.     }
  1492.     if (fun.type & TYPE_MOD_NO_MASK) {
  1493.         fun.flags |= NAME_INHERITED;
  1494.     } else if (!(fun.flags & NAME_HIDDEN)) {
  1495.         fun.flags |= NAME_UNDEFINED;
  1496.     }
  1497.     /*
  1498.      * public functions should not become private when inherited
  1499.      * 'private'
  1500.      */
  1501.     new_type = type;
  1502.     if (fun.type & TYPE_MOD_PUBLIC)
  1503.         new_type &= ~TYPE_MOD_PRIVATE;
  1504.     fun.type |= new_type;
  1505.     /* marion
  1506.      * this should make possible to inherit a heart beat function, and
  1507.      * thus to mask it if wanted.
  1508.      */
  1509.     if (heart_beat == -1 && fun.name[0] == 'h' &&
  1510.         strcmp(fun.name, "heart_beat") == 0)
  1511.     {
  1512.         heart_beat = mem_block[A_FUNCTIONS].current_size /
  1513.         sizeof (struct function);
  1514.     } else if (fun.name[0] == '_' && strcmp(fun.name, "__INIT") == 0) {
  1515.         initializer = i;
  1516.         fun.flags |= NAME_INHERITED;
  1517.     }
  1518.     add_to_mem_block(A_FUNCTIONS, (char *)&fun, sizeof fun);
  1519.     /*
  1520.      * Copy information about the types of the arguments, if it is
  1521.      * available.
  1522.      */
  1523.     tmp_short = INDEX_START_NONE;    /* Presume not available. */
  1524.     if (from->type_start != 0 && from->type_start[i] != INDEX_START_NONE)
  1525.     {
  1526.         int arg;
  1527.         /*
  1528.          * They are available for function number 'i'. Copy types of
  1529.          * all arguments, and remember where they started.
  1530.          */
  1531.         tmp_short = mem_block[A_ARGUMENT_TYPES].current_size /
  1532.         sizeof from->argument_types[0];
  1533.         for (arg = 0; arg < fun.num_arg; arg++) {
  1534.         add_to_mem_block(A_ARGUMENT_TYPES,
  1535.                  &from->argument_types[from->type_start[i]],
  1536.                  sizeof (unsigned short));
  1537.         }
  1538.     }
  1539.     /*
  1540.      * Save the index where they started. Every function will have an
  1541.      * index where the type info of arguments starts.
  1542.      */
  1543.     add_to_mem_block(A_ARGUMENT_INDEX, &tmp_short, sizeof tmp_short);
  1544.     }
  1545.     return initializer;
  1546. }
  1547.  
  1548. /*
  1549.  * Copy all variabel names from the object that is inherited from.
  1550.  * It is very important that they are stored in the same order with the
  1551.  * same index.
  1552.  */
  1553. static void copy_variables(from, type)
  1554.     struct program *from;
  1555.     int type;
  1556. {
  1557.     int i;
  1558.  
  1559.     for (i=0; i<from->num_variables; i++) {
  1560.     int new_type = type;
  1561.     int n = check_declared(from->variable_names[i].name);
  1562.  
  1563.     if (n != -1 && (VARIABLE(n)->type & TYPE_MOD_NO_MASK)) {
  1564.         char *p = (char *)alloca(80 +
  1565.                      strlen(from->variable_names[i].name));
  1566.         sprintf(p, "Illegal to redefine 'nomask' variable \"%s\"",
  1567.             VARIABLE(n)->name);
  1568.         yyerror(p);
  1569.     }
  1570.     /*
  1571.      * 'public' variables should not become private when inherited
  1572.      * 'private'.
  1573.      */
  1574.     if (from->variable_names[i].type & TYPE_MOD_PUBLIC)
  1575.         new_type &= ~TYPE_MOD_PRIVATE;
  1576.     define_variable(from->variable_names[i].name,
  1577.             from->variable_names[i].type | new_type,
  1578.             from->variable_names[i].type & TYPE_MOD_PRIVATE ?
  1579.                 NAME_HIDDEN : 0);
  1580.     }
  1581. }
  1582.  
  1583. /*
  1584.  * This function is called from lex.c for every new line read from the
  1585.  * "top" file (means not included files). Some new lines are missed,
  1586.  * as with #include statements, so it is compensated for.
  1587.  */
  1588. void store_line_number_info()
  1589. {
  1590.     unsigned short offset = mem_block[A_PROGRAM].current_size;
  1591.  
  1592.     while(mem_block[A_LINENUMBERS].current_size / sizeof (short) <
  1593.       current_line)
  1594.     {
  1595.     add_to_mem_block(A_LINENUMBERS, (char *)&offset, sizeof offset);
  1596.     }
  1597. }
  1598.  
  1599. static char *get_type_name(type)
  1600.     int type;
  1601. {
  1602.     static char buff[100];
  1603.     static char *type_name[] = { "unknown", "int", "string",
  1604.                      "void", "object", "mixed", "mapping" };
  1605.     int pointer = 0;
  1606.  
  1607.     buff[0] = 0;
  1608.     if (type & TYPE_MOD_STATIC)
  1609.     strcat(buff, "static ");
  1610.     if (type & TYPE_MOD_NO_MASK)
  1611.     strcat(buff, "nomask ");
  1612.     if (type & TYPE_MOD_PRIVATE)
  1613.     strcat(buff, "private ");
  1614.     if (type & TYPE_MOD_PROTECTED)
  1615.     strcat(buff, "protected ");
  1616.     if (type & TYPE_MOD_PUBLIC)
  1617.     strcat(buff, "public ");
  1618.     if (type & TYPE_MOD_VARARGS)
  1619.     strcat(buff, "varargs ");
  1620.     type &= TYPE_MOD_MASK;
  1621.     if (type & TYPE_MOD_POINTER) {
  1622.     pointer = 1;
  1623.     type &= ~TYPE_MOD_POINTER;
  1624.     }
  1625.     if (type >= sizeof type_name / sizeof type_name[0])
  1626.     fatal("Bad type\n");
  1627.     strcat(buff, type_name[type]);
  1628.     strcat(buff," ");
  1629.     if (pointer)
  1630.     strcat(buff, "* ");
  1631.     return buff;
  1632. }
  1633.  
  1634. void type_error(str, type)
  1635.     char *str;
  1636.     int type;
  1637. {
  1638.     static char buff[100];
  1639.     char *p;
  1640.     p = get_type_name(type);
  1641.     if (strlen(str) + strlen(p) + 5 >= sizeof buff) {
  1642.     yyerror(str);
  1643.     } else {
  1644.     strcpy(buff, str);
  1645.     strcat(buff, ": \"");
  1646.     strcat(buff, p);
  1647.     strcat(buff, "\"");
  1648.     yyerror(buff);
  1649.     }
  1650. }
  1651.  
  1652. /*
  1653.  * Compile an LPC file.
  1654.  */
  1655. void compile_file() {
  1656.     int yyparse();
  1657.  
  1658.     prolog();
  1659.     yyparse();
  1660.     epilog();
  1661. }
  1662.  
  1663. static char *get_two_types(type1, type2)
  1664.     int type1, type2;
  1665. {
  1666.     static char buff[100];
  1667.  
  1668.     strcpy(buff, "( ");
  1669.     strcat(buff, get_type_name(type1));
  1670.     strcat(buff, "vs ");
  1671.     strcat(buff, get_type_name(type2));
  1672.     strcat(buff, ")");
  1673.     return buff;
  1674. }
  1675.  
  1676. /*
  1677.  * The program has been compiled. Prepare a 'struct program' to be returned.
  1678.  */
  1679. void epilog() {
  1680.     int size, i;
  1681.     char *p;
  1682.     struct function *funp;
  1683.     static int current_id_number = 1;
  1684.  
  1685. #ifdef DEBUG
  1686.     if (num_parse_error == 0 && type_of_arguments.current_size != 0)
  1687.     fatal("Failed to deallocate argument type stack\n");
  1688. #endif
  1689.     /*
  1690.      * Define the __INIT function, but only if there was any code
  1691.      * to initialize.
  1692.      */
  1693.     if (first_last_initializer_end != last_initializer_end) {
  1694.     define_new_function("__INIT", 0, 0, 0, 0, 0);
  1695.     /*
  1696.      * Change the last jump after the last initializer into a
  1697.      * return(1) statement.
  1698.      */
  1699.     mem_block[A_PROGRAM].block[last_initializer_end-1] =
  1700.         F_CONST1 - F_OFFSET;
  1701.     mem_block[A_PROGRAM].block[last_initializer_end-0] =
  1702.         F_RETURN - F_OFFSET;
  1703.     }
  1704.  
  1705.     /*
  1706.      * If functions are undefined, replace them by definitions done
  1707.      * by inheritance. All explicit "name::func" are already resolved.
  1708.      */
  1709.     for (i = 0; i < mem_block[A_FUNCTIONS].current_size; i += sizeof *funp) {
  1710.     funp = (struct function *)(mem_block[A_FUNCTIONS].block + i);
  1711.     if (!(funp->flags & NAME_UNDEFINED))
  1712.         continue;
  1713.     find_inherited(funp);
  1714.     }
  1715.     if (num_parse_error > 0) {
  1716.     prog = 0;
  1717.     for (i=0; i<NUMAREAS; i++)
  1718.         xfree(mem_block[i].block);
  1719.     return;
  1720.     }
  1721.     size = align(sizeof (struct program));
  1722.     for (i=0; i<NUMPAREAS; i++)
  1723.     size += align(mem_block[i].current_size);
  1724.     p = (char *)xalloc(size);
  1725.     prog = (struct program *)p;
  1726.     *prog = NULL_program;
  1727.     prog->total_size = size;
  1728.     prog->ref = 0;
  1729.     prog->heart_beat = heart_beat;
  1730.     prog->name = string_copy(current_file);
  1731.     prog->id_number = current_id_number++;
  1732.     total_prog_block_size += prog->total_size;
  1733.     total_num_prog_blocks += 1;
  1734.  
  1735.     p += align(sizeof (struct program));
  1736.     prog->program = p;
  1737.     if (mem_block[A_PROGRAM].current_size)
  1738.     memcpy(p, mem_block[A_PROGRAM].block,
  1739.            mem_block[A_PROGRAM].current_size);
  1740.     prog->program_size = mem_block[A_PROGRAM].current_size;
  1741.  
  1742.     p += align(mem_block[A_PROGRAM].current_size);
  1743.     prog->line_numbers = (unsigned short *)p;
  1744.     if (mem_block[A_LINENUMBERS].current_size)
  1745.     memcpy(p, mem_block[A_LINENUMBERS].block,
  1746.            mem_block[A_LINENUMBERS].current_size);
  1747.  
  1748.     p += align(mem_block[A_LINENUMBERS].current_size);
  1749.     prog->functions = (struct function *)p;
  1750.     prog->num_functions = mem_block[A_FUNCTIONS].current_size /
  1751.     sizeof (struct function);
  1752.     if (mem_block[A_FUNCTIONS].current_size)
  1753.     memcpy(p, mem_block[A_FUNCTIONS].block,
  1754.            mem_block[A_FUNCTIONS].current_size);
  1755.  
  1756.     p += align(mem_block[A_FUNCTIONS].current_size);
  1757.     prog->strings = (char **)p;
  1758.     prog->num_strings = mem_block[A_STRINGS].current_size /
  1759.     sizeof (char *);
  1760.     if (mem_block[A_STRINGS].current_size)
  1761.     memcpy(p, mem_block[A_STRINGS].block,
  1762.            mem_block[A_STRINGS].current_size);
  1763.  
  1764.     p += align(mem_block[A_STRINGS].current_size);
  1765.     prog->variable_names = (struct variable *)p;
  1766.     prog->num_variables = mem_block[A_VARIABLES].current_size /
  1767.     sizeof (struct variable);
  1768.     if (mem_block[A_VARIABLES].current_size)
  1769.     memcpy(p, mem_block[A_VARIABLES].block,
  1770.            mem_block[A_VARIABLES].current_size);
  1771.  
  1772.     p += align(mem_block[A_VARIABLES].current_size);
  1773.     prog->num_inherited = mem_block[A_INHERITS].current_size /
  1774.     sizeof (struct inherit);
  1775.     if (prog->num_inherited) {
  1776.     memcpy(p, mem_block[A_INHERITS].block,
  1777.            mem_block[A_INHERITS].current_size);
  1778.     prog->inherit = (struct inherit *)p;
  1779.     } else
  1780.     prog->inherit = 0;
  1781.     
  1782.     prog->argument_types = 0;    /* For now. Will be fixed someday */
  1783.  
  1784.     prog->type_start = 0;
  1785.     for (i=0; i<NUMAREAS; i++)
  1786.         xfree((char *)mem_block[i].block);
  1787.  
  1788.     /*  marion
  1789.     Do referencing here - avoid multiple referencing when an object
  1790.     inherits more than one object and one of the inherited is already
  1791.     loaded and not the last inherited
  1792.     */
  1793.     reference_prog (prog, "epilog");
  1794.     for (i = 0; i < prog->num_inherited; i++) {
  1795.     reference_prog (prog->inherit[i].prog, "inheritance");
  1796.     }
  1797. }
  1798.  
  1799. /*
  1800.  * Initialize the environment that the compiler needs.
  1801.  */
  1802. static void prolog() {
  1803.     int i;
  1804.  
  1805.     if (type_of_arguments.block == 0) {
  1806.     type_of_arguments.max_size = 100;
  1807.     type_of_arguments.block = xalloc(type_of_arguments.max_size);
  1808.     }
  1809.     type_of_arguments.current_size = 0;
  1810.     approved_object = 0;
  1811.     last_push_indexed = -1;
  1812.     last_push_local = -1;
  1813.     last_push_identifier = -1;
  1814.     prog = 0;        /* 0 means fail to load. */
  1815.     heart_beat = -1;
  1816.     comp_stackp = 0;    /* Local temp stack used by compiler */
  1817.     current_continue_address = 0;
  1818.     current_break_address = 0;
  1819.     num_parse_error = 0;
  1820.     free_all_local_names();    /* In case of earlier error */
  1821.     /* Initialize memory blocks where the result of the compilation
  1822.      * will be stored.
  1823.      */
  1824.     for (i=0; i < NUMAREAS; i++) {
  1825.     mem_block[i].block = xalloc(START_BLOCK_SIZE);
  1826.     mem_block[i].current_size = 0;
  1827.     mem_block[i].max_size = START_BLOCK_SIZE;
  1828.     }
  1829.     add_new_init_jump();
  1830.     first_last_initializer_end = last_initializer_end;
  1831. }
  1832.  
  1833. /*
  1834.  * Add a trailing jump after the last initialization code.
  1835.  */
  1836. void add_new_init_jump() {
  1837.     /*
  1838.      * Add a new jump.
  1839.      */
  1840.     ins_f_byte(F_JUMP);
  1841.     last_initializer_end = mem_block[A_PROGRAM].current_size;
  1842.     ins_short(0);
  1843. }
  1844.